home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / labelsrc.pqs / labelsrc.pas
Encoding:
Pascal/Delphi Source File  |  1985-06-03  |  14.4 KB  |  413 lines
  1. program LabelEditor;
  2. {by Guy Gallo, using input2.pas by Henry Lifton and a piece of }
  3. {Philip Burns' pibmenus                                        }
  4.  
  5. {$C-}      {Turns off the control character checking -- makes output faster }
  6.  
  7. type
  8.    Ascii   = set of ' '..'~'; { Range of printable characters }
  9.    AnyStr   = string[35];      { String to hold entries - length=longest Entry }
  10.  
  11. const
  12.    All:    Ascii = [' '..'~'];
  13.    Bks   = #08;  { Backspace Key  }
  14.    TB    = #09;  {Tab}
  15.    Cr    = #13;  {Carriage return }
  16.    Ff    = 1;   { These constants represent the number of the first and last }
  17.    Lf    = 6;   { fields in the Entry and will change with each program      }
  18.  
  19. var
  20.    code,i,num_more,Field:        integer;              { Field counter  }
  21.    Key:          array[1..2] of char;  { keystroke entered at the keyboard }
  22.    ch:           string[3];  { Allows for function and special keys}
  23.    Ks:           char;                 { The character to print }
  24.    Ret,
  25.    Fini,
  26.    Done:         boolean;                     { True or False indicators }
  27.    Col,Row,                                   { Column and Row }
  28.    CurPos,                                    { Current cursor position }
  29.    PromptCol,                                 { Column for start of prompt }
  30.    Len:          array[Ff..Lf] of integer;    { Max. length of input field }
  31.    Prompt,Ans:   array[Ff..Lf] of AnyStr;      { Array for Prompts & Answers }
  32.    Allow:        array[Ff..Lf] of Ascii;      { Defines Allowable char. set  }
  33.  
  34.        {     Minor procedures - called often from main procedure       }
  35. (*----------------------------------------------------------------------*)
  36. (*        Draw_Menu_Frame --- Draw a Frame    by Philip Burns           *)
  37. (*----------------------------------------------------------------------*)
  38.  
  39. Procedure Draw_Menu_Frame( UpperLeftX,  UpperLeftY,
  40.                            LowerRightX, LowerRightY : Integer;
  41.                            Frame_Color, Title_Color : Integer;
  42.                            Menu_Title: AnyStr );
  43.  
  44. (*                                                                      *)
  45. (*     Procedure:  Draw_Menu_Frame                                      *)
  46. (*                                                                      *)
  47. (*     Purpose:    Draws a titled frame using PC graphics characters    *)
  48. (*                                                                      *)
  49. (*     Calling Sequence:                                                *)
  50. (*                                                                      *)
  51. (*        Draw_Menu_Frame( UpperLeftX,  UpperLeftY,                     *)
  52. (*                         LowerRightX, LowerRightY,                    *)
  53. (*                         Frame_Color, Title_Color : Integer;          *)
  54. (*                         Menu_Title: AnyStr );                        *)
  55. (*                                                                      *)
  56. (*           UpperLeftX,  UpperLeftY  --- Upper left coordinates        *)
  57. (*           LowerRightX, LowerRightY --- Lower right coordinates       *)
  58. (*           Frame_Color              --- Color for frame               *)
  59. (*           Title_Color              --- Color for title text          *)
  60. (*           Menu_Title               --- Menu Title                    *)
  61. (*                                                                      *)
  62. (*     Calls:   GoToXY                                                  *)
  63. (*              Window                                                  *)
  64. (*              ClrScr                                                  *)
  65. (*                                                                      *)
  66. (*     Remarks:                                                         *)
  67. (*                                                                      *)
  68. (*        The area inside the frame is cleared after the frame is       *)
  69. (*        drawn.  If a box without a title is desired, enter a null     *)
  70. (*        string for a title.                                           *)
  71.  
  72. Var
  73.    I  : Integer;
  74.    L  : Integer;
  75.    LT : Integer;
  76.  
  77. Begin (* Draw_Menu_Frame *)
  78.  
  79.                                    (* Move to top left-hand corner of menu *)
  80.    GoToXY( UpperLeftX, UpperLeftY );
  81.  
  82.    L  := LowerRightX - UpperLeftX;
  83.    LT := LENGTH( Menu_Title );
  84.                                    (* Adjust title length if necessary *)
  85.    If LT > ( L - 5 ) Then Menu_Title[0] := CHR( L - 5 );
  86.  
  87.                                    (* Color for frame                  *)
  88.    TextColor( Frame_Color );
  89.                                    (* Write upper left hand corner and title *)
  90.    If LT > 0 Then
  91.       Begin
  92.          Write('╒[ ');
  93.          TextColor( Title_Color );
  94.          Write( Menu_Title );
  95.          TextColor( Frame_Color );
  96.          Write(' ]');
  97.       End
  98.    Else
  99.       Write('╒════');
  100.                                    (* Draw remainder of top of frame *)
  101.  
  102.    For I := ( UpperLeftX + LT + 5 ) To ( LowerRightX - 1 ) Do Write('═');
  103.  
  104.    Write('╕');
  105.                                   (* Draw sides of frame *)
  106.  
  107.    For I := UpperLeftY+1 To LowerRightY-1 Do
  108.       Begin
  109.          GoToXY( UpperLeftX  , I );  Write( '│' );
  110.          GoToXY( LowerRightX , I );  Write( '│' );
  111.       End;
  112.  
  113.                                   (* Draw bottom of frame     *)
  114.  
  115.    GoToXY( UpperLeftX, LowerRightY );
  116.    Write( '╘' );
  117.  
  118.    For I := UpperLeftX+1 To LowerRightX-1 Do Write( '═' );
  119.    Write( '╛' );
  120.  
  121.                                    (* Establish scrolling window area *)
  122.  
  123.    Window( UpperLeftX+1, UpperLeftY+1, LowerRightX-1, LowerRightY-1 );
  124.  
  125.                                    (* Clear out the window area       *)
  126.    Clrscr;
  127.                                    (* Ensure proper color for text    *)
  128.    TextColor( Title_Color );
  129.  
  130. End   (* Draw_Menu_Frame *);
  131.  
  132. procedure Bell;          {For when something goes wrong}
  133.   begin
  134.     Sound(440);
  135.     Delay(250);
  136.     NoSound;
  137.   end;    {Bell}
  138.  
  139. procedure Print_Prn(outchar:char);
  140. begin
  141. write(lst,outchar);
  142. end;
  143.  
  144. procedure Checkfield;   { See if field should wrap around }
  145.   begin
  146.     if Field<Ff then Field:=Lf;
  147.     if Field>Lf then Field:=Ff;
  148.   end;   { Checkfield }
  149.  
  150. procedure Brackets;     { Print Entry limiters }
  151.   begin
  152.     GotoXY(Col[Field]-1,Row[Field]);
  153.     Write('[');
  154.     GotoXY(Col[Field]+Len[Field],Row[Field]);
  155.     Write(']');
  156.   end;   { Brackets }
  157.  
  158. procedure NoBrackets;   {Remove Entry limiters }
  159.   begin
  160.     GotoXY(Col[Field]-1,Row[Field]);
  161.     Write(' ');
  162.     GotoXY(Col[Field]+Len[Field],Row[Field]);
  163.     Write(' ')
  164.   end;    { NoBrackets }
  165.  
  166.             { This is the main routine and calls all those above }
  167.  
  168. procedure GetInput;
  169.  
  170. begin  {GetInput}
  171.   Ret:=false;
  172.   repeat {until Ret}
  173.     Brackets;
  174.     begin                                      {Read the keyboard}
  175.       GotoXY(CurPos[Field],Row[Field]);
  176.       Read(kbd,Key[1]);
  177.       if (Key[1]=chr(27)) or (Key[1]=chr(0)) then
  178.         begin                                  {Read second keystroke}
  179.           Read(kbd,Key[2]);
  180.             case Key[2] of
  181.               #59:begin
  182.               window(1,1,80,24);
  183.               clrscr;
  184.                halt;  {Function Key 1 pressed - all Done}
  185.                end;
  186.               #72: begin  {Move back (up) one field}
  187.                      NoBrackets;
  188.                      Field:=Field-1;
  189.                    end;   {Move back}
  190.               #80: begin  {Move ahead (down) one field}
  191.                      NoBrackets;
  192.                      Field:=Field+1;
  193.                    end;   {Move ahead}
  194.               #75: begin  {Cursor Left (backwards) one stroke}
  195.                      CurPos[Field]:=CurPos[Field]-1;
  196.                      if CurPos[Field] <Col[Field] then
  197.                        begin  {Back one field}
  198.                          CurPos[Field]:=Col[Field]+Length(Ans[Field]);
  199.                          Bell;NoBrackets;
  200.                          Field:=Field-1;
  201.                        end;   {Back one field}
  202.                    end;   {Cursor left}
  203.               #77: begin  {Cursor right (ahead) one stroke}
  204.                      CurPos[Field]:=CurPos[Field]+1;
  205.                      if CurPos[Field] >Col[Field]+Len[Field] then
  206.                      begin  {Ahead one field}
  207.                        CurPos[Field]:=Col[Field]+Length(Ans[Field]);
  208.                        Bell;NoBrackets;
  209.                        Field:=Field+1;
  210.                      end;   {Ahead one field}
  211.                    end;   {Cursor right}
  212.               #60: begin  {F2  pressed - this Entry o.k.}
  213.                       Ret:=true;
  214.                    end;   {F2 Key }
  215.               #61: print_prn(#10); {LineFeed}
  216. end; {Case - second keystroke}
  217.           Checkfield; {check for first or last field overlow}
  218.         end;  {Read second keystroke}
  219.       Ks:=Key[1];  {Nothing very special so interpret Key[1]  }
  220.       case Ks of  {check keystroke for other meanings}
  221.         Tb: begin
  222.             CurPos[Field] := CurPos[Field] + 5;
  223.             insert('     ',Ans[Field],CurPos[Field]);
  224.             end;
  225.         Cr:  begin  {carriage return}
  226.                NoBrackets;
  227.                Field:=Field+1;
  228.                Checkfield;
  229.              end;   {carriage return}
  230.         Bks: begin  {Should we backspace}
  231.                if  CurPos[Field]<=Col[Field] then Bell else
  232.                begin  {backspace}
  233.                  delete(Ans[Field],CurPos[Field]-Col[Field],1);
  234.                  CurPos[Field]:=CurPos[Field]-1;
  235.                  GotoXY(CurPos[Field],Row[Field]);
  236.                  Write(' ');
  237.                  GotoXY(CurPos[Field],Row[Field]);
  238.                end;  {backspace}
  239.              end; {should we backspace}
  240.       end; {Case Statement - Check keystroke}
  241. {Nothing there? -- must be a letter or number}
  242. { Now check if it is allowable }
  243.       if Ks in Allow[Field] then
  244.       begin  {check length of answer}
  245.         if Length(Ans[Field]) <= Len[Field] then
  246.         if CurPos[Field]-Col[Field]+1>Len[Field]  then  Bell else
  247.         begin                       {Write keystroke}
  248.           HighVideo;                {Bright screen  }
  249.           Write(Ks);
  250.           LowVideo;                 { Dim Screen }
  251.           delete(Ans[Field],CurPos[Field]-Col[Field]+1,1);
  252.           insert(Ks,Ans[Field],CurPos[Field]-Col[Field]+1);
  253.           CurPos[Field]:=CurPos[Field]+1;
  254.         end;                        {Write keystroke}
  255.       end;                          {check length of answer}
  256.     end;                            { Reading Keyboard }
  257.   until Ret;
  258.   NoBrackets;
  259.  
  260. end;                                {GetInput}
  261.  
  262.     { This is the end of the main routine - following is for program use}
  263.  
  264. procedure Titles;
  265.  
  266. type
  267.   T = string[80];
  268.  
  269. var
  270.   Aa: integer;
  271.   Title: T;
  272.  
  273. begin
  274.  
  275. TextColor(0); TextBackGround(7);
  276.   Title:='F1 = Quit   F2 = Print  F3 = Line Feed';Aa:=0;
  277.   Aa:= (80-Length(title)) div 2;
  278.   GotoXY(Aa,21);Write(Title);
  279.   Title:='Up & Down Arrows change fields';Aa:=0;
  280.   Aa:= (80-Length(title)) div 2;
  281.   GotoXY(Aa,23);Write(Title);
  282.  
  283. end;           {Titles}
  284.  
  285. {.PA}
  286. {Use this procedure to load the array holding the parameters for the entry}
  287. {  PromptCol = Column prompt is to start
  288.    Row       = Row of prompt and entry
  289.    Len       = Length of input field
  290.    Prompt    = Text of prompt
  291.    Col       = Column where input is to start (computed automatically)
  292.    CurPos    = Current cursor position (internal to the routine)
  293.    Ans       = The entry is returned to your program in this variable
  294.    Allow     = The set of acceptable characters as defined earlier
  295. }
  296.  
  297. procedure LoadArray;
  298. begin
  299.  for Field:=Ff to Lf do
  300.   begin  {do loop}
  301.    case Field OF
  302.     1:begin
  303.        PromptCol[Field]:=2;Row[Field]:=1;Len[Field]:=35;
  304.        Prompt[Field]:='Line 1: ';
  305.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  306.        CurPos[Field]:=Col[Field];
  307.        Ans[Field]:='';
  308.        Allow[Field]:=all;
  309.       end;
  310.  
  311.     2:begin
  312.        PromptCol[Field]:=2;Row[Field]:=2;Len[Field]:=35;
  313.        Prompt[Field]:='Line 2: ';
  314.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  315.        CurPos[Field]:=Col[Field];
  316.        Ans[Field]:='';
  317.        Allow[Field]:=all;
  318.       end;
  319.  
  320.     3:begin
  321.        PromptCol[Field]:=2;Row[Field]:=3;Len[Field]:=35;
  322.        Prompt[Field]:='Line 3: ';
  323.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  324.        CurPos[Field]:=Col[Field];
  325.        Ans[Field]:='';
  326.        Allow[Field]:=all;
  327.       end;
  328.  
  329.     4:begin
  330.        PromptCol[Field]:=2;Row[Field]:=4;Len[Field]:=35;
  331.        Prompt[Field]:='Line 4: ';
  332.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  333.        CurPos[Field]:=Col[Field];
  334.        Ans[Field]:='';
  335.        Allow[Field]:=all;
  336.       end;
  337.  
  338.     5:begin
  339.        PromptCol[Field]:=2;Row[Field]:=5;Len[Field]:=35;
  340.        Prompt[Field]:='Line 5: ';
  341.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  342.        CurPos[Field]:=Col[Field];
  343.        Ans[Field]:='';
  344.        Allow[Field]:=all;
  345.       end;
  346.  
  347.     6:begin
  348.        PromptCol[Field]:=2;Row[Field]:=6;Len[Field]:=35;
  349.        Prompt[Field]:='Line 6: ';
  350.        Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
  351.        CurPos[Field]:=Col[Field];
  352.        Ans[Field]:='';
  353.        Allow[Field]:=all;
  354.       end;
  355.  
  356.    end; {doloop}
  357.   end; {case}
  358. end; {LoadArray}
  359.  
  360. procedure Prompts;
  361. begin
  362.   for Field:=Ff to Lf do
  363.     begin
  364.       LowVideo;
  365.       GotoXY(PromptCol[Field],Row[Field]);
  366.       Write(Prompt[Field]) { prompt is from an array }
  367.     end;
  368. end;{Prompts}
  369.  
  370. procedure print_out;
  371. begin
  372.   for Field:=Ff to Lf do
  373.      begin
  374.        Writeln(lst,Ans[Field]);
  375.      end;
  376.   Field:=Ff;
  377.   writeln;
  378.   writeln;
  379. end;                     {print_out}
  380.  
  381.  
  382.         {This is the start of the Program}
  383. begin
  384. Titles;
  385.   Draw_Menu_Frame(15,10,65,18,7,15,'Label Editor   G. Gallo');
  386.   Done:=false;Fini:=false;
  387.   while not Fini do
  388.   repeat
  389.   LoadArray;
  390.   Prompts;
  391.         Field:=Ff;
  392.         GetInput;
  393.         gotoxy(2,7);
  394.         HighVideo;
  395.         write('Number of labels to print [<enter> for 1]:  ');
  396.         read(ch);
  397.         if length(ch) = 0 then num_more := 1
  398.         else
  399.            Val(ch,num_more,code);
  400.         while num_more > 0 do
  401.              begin
  402.                  print_out;
  403.                  num_more := num_more - 1;
  404.              end;
  405.         done := true;
  406.   ClrScr;
  407.   for Field:=Ff TO Lf do       {Initialize fields}
  408.         begin
  409.           CurPos[Field]:=Col[Field];
  410.         end;                       {Initialize fields}
  411.  until Done;
  412. end.   {Fini}
  413.